home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 090 / fractal.arc / FRACTAL4.BAS < prev    next >
Encoding:
BASIC Source File  |  1985-10-26  |  4.1 KB  |  131 lines
  1. 10 '-----------------------------------
  2. 20 ' FRACTAL CURVES                 AEM
  3. 30 '-----------------------------------
  4. 40  CLS:SCREEN 1,1:OPTION BASE 1
  5. 50  KEY OFF:DEFINT I-N:PI=3.141593
  6. 60  LOCATE 12,17:PRINT "Wait..."
  7. 70  DIM NH(50),NV(50),ID(50)
  8. 80  NM=5000:DIM X(NM),Y(NM),IC(NM)
  9. 90 '----- INPUT PARAMETERS ------------
  10. 100 RESTORE 1040
  11. 110 READ NL,ND,YOX,SC,IP
  12. 120 FOR I=1 TO NL-1:READ NH(I):NEXT
  13. 130 FOR I=1 TO NL-1:READ NV(I):NEXT
  14. 140 FOR I=1 TO NL  :READ ID(I):NEXT
  15. 150 '----- POSITION THE CURVE ---------
  16. 160 XMIN=.5-.5*SC:XMAX=.5+.5*SC
  17. 170 ON IP GOTO 190,200,210
  18. 180 PRINT "IP>3":END
  19. 190 YMAX=.36*SC:YMIN=-.36*SC:GOTO 220
  20. 200 YMAX=.54*SC:YMIN=-.18*SC:GOTO 220
  21. 210 YMAX=.6*SC :YMIN=-.12*SC
  22. 220 VIEW:WINDOW (XMIN,YMIN)-(XMAX,YMAX)
  23. 230 '----- INITIALIZE -----------------
  24. 240 DIM ICT(1):IC(1)=1:LAST=2
  25. 250 X(1)=0!:X(2)=1!:Y(1)=0!:Y(2)=0!
  26. 260 '----- MAIN ROUTINE ---------------
  27. 270 FOR LEVEL=1 TO 4:CLS
  28. 280 LOCATE 25,1:PRINT "LEVEL =";LEVEL;
  29. 290 NNEW=(LAST-1)*NL+1:GOSUB 430
  30. 300 GOSUB 500:LAST=NNEW
  31. 310 IF LEVEL<5 THEN GOSUB 720
  32. 320 '----- DRAW THE CURVE -------------
  33. 330 PSET (X(1),Y(1)):FOR IP=2 TO LAST
  34. 340 LINE -(X(IP),Y(IP)):NEXT IP
  35. 350 '----- CONTINUE? ------------------
  36. 360 LOCATE 1,1
  37. 370 PRINT "ENTER to continue";
  38. 380 I$=INKEY$:IF I$="" THEN 360
  39. 390 IF I$=CHR$(13) THEN NEXT LEVEL
  40. 400 END
  41. 410 '----- END PROGRAM ----------------
  42. 420 '----- EXPAND X AND Y ARRAYS ------
  43. 430 IF NNEW<NM THEN 450
  44. 440 PRINT "...... MEMORY OVERFLOW":END
  45. 450 PRINT "......";NNEW;"POINTS"
  46. 460 FOR I=1 TO LAST:IFROM=LAST-I+1
  47. 470 ITO=(IFROM-1)*NL+1:X(ITO)=X(IFROM)
  48. 480 Y(ITO)=Y(IFROM):NEXT I:     RETURN
  49. 490 '----- GENERATING FUNCTION --------
  50. 500 FOR I=2 TO LAST:II=(I-2)*NL+1
  51. 510 XS=X(II):YS=Y(II) :XF=X(II+NL)
  52. 520 YF=Y(II+NL):GOSUB 930
  53. 530 DX=(XF-XS)/ND:DY=(YF-YS)/ND
  54. 540 D=SQR(DX^2+DY^2):S=SIN(T):C=COS(T)
  55. 550 FOR J=1 TO NL-1:K=II+J:L=NL-J
  56. 560 ON IC(I-1) GOTO 570,600,640,670
  57. 570 X(K)=(XS+DX*NH(J))-D*YOX*NV(J)*S
  58. 580 Y(K)=(YS+DY*NH(J))+D*YOX*NV(J)*C
  59. 590 GOTO 700
  60. 600 NDH=ND-NH(L)
  61. 610 X(K)=(XS+DX*NDH)+D*YOX*NV(L)*S
  62. 620 Y(K)=(YS+DY*NDH)-D*YOX*NV(L)*C
  63. 630 GOTO 700
  64. 640 X(K)=(XS+DX*NH(J))+D*YOX*NV(J)*S
  65. 650 Y(K)=(YS+DY*NH(J))-D*YOX*NV(J)*C
  66. 660 GOTO 700
  67. 670 NDH=ND-NH(L)
  68. 680 X(K)=(XS+DX*NDH)-D*YOX*NV(L)*S
  69. 690 Y(K)=(YS+DY*NDH)+D*YOX*NV(L)*C
  70. 700 NEXT J:NEXT I:              RETURN
  71. 710 '----- EXPAND IC ARRAY ------------
  72. 720 NUM=NL^(LEVEL-1)
  73. 730 ERASE ICT:  DIM ICT(NUM)
  74. 740 FOR I=1 TO NUM:ICT(I)=IC(I):NEXT
  75. 750 FOR I=1 TO NUM
  76. 760 ON ICT(I) GOTO 770,790,840,890
  77. 770 FOR J=1 TO NL:K=NL*(I-1)+J
  78. 780 IC(K)=ID(J):NEXT J:       GOTO 910
  79. 790 FOR J=1 TO NL:K=NL*(I-1)+J
  80. 800 ON ID(NL-J+1) GOTO 810,810,820,820
  81. 810 IC(K)=3-ID(NL-J+1):GOTO 830
  82. 820 IC(K)=7-ID(NL-J+1)
  83. 830 NEXT J:                   GOTO 910
  84. 840 FOR J=1 TO NL:K=NL*(I-1)+J
  85. 850 ON ID(J) GOTO 860,860,870,870
  86. 860 IC(K)=ID(J)+2:GOTO 880
  87. 870 IC(K)=ID(J)-2
  88. 880 NEXT J:                   GOTO 910
  89. 890 FOR J=1 TO NL:K=NL*(I-1)+J
  90. 900 IC(K)=5-ID(NL-J+1):NEXT J
  91. 910 NEXT I:                     RETURN
  92. 920 '----- FIND ANGLE WRT +X AXIS -----
  93. 930 DX=XF-XS:DY=YF-YS
  94. 940 IF DX=0 THEN 990
  95. 950 T=ATN(DY/DX)
  96. 960 IF DX<0! THEN 1000
  97. 970 IF DY<0! THEN T=T+PI*2
  98. 980 GOTO 1010
  99. 990 T=PI/2:IF DY>=0! THEN 1010
  100. 1000 T=T+PI
  101. 1010 RETURN
  102. 1020 '----- DATA ----------------------
  103. 1030 '                    SAUSAGE LINK
  104. 1040  DATA 8,4,1,1,1
  105. 1050  DATA 1,1,2,2,2,3,3
  106. 1060  DATA 0,1,1,0,-1,-1,0
  107. 1070  DATA 1,1,1,1,1,1,1,1
  108. 1080 '                        PINWHEEL
  109. 1090  DATA 10,4,0.57735,1,1
  110. 1100  DATA 1,2,2,3,2,1,2,2,3
  111. 1110  DATA 1,0,2,1,0,-1,-2,0,-1
  112. 1120  DATA 1,1,1,1,1,1,1,1,1,1
  113. 1130 '                       ARROWHEAD
  114. 1140  DATA 10,8,1.732051,1,1
  115. 1150  DATA 2,4,3,5,6,4,3,5,6
  116. 1160  DATA 0,0,1,1,0,0,-1,-1,0
  117. 1170  DATA 1,1,1,1,1,1,1,1,1
  118. 1180 '            HEXAGONAL CONNECTION
  119. 1190  DATA 10,8,1.732051,1,1
  120. 1200  DATA 2,3,5,6,4,2,3,5,6
  121. 1210  DATA 0,1,1,0,0,0,-1,-1,0
  122. 1220  DATA 1,1,1,1,1,1,1,1,1,1
  123. 1230 '                   SHOGUN HELMET
  124. 1240  DATA 4,4,1.73205,1,2
  125. 1250  DATA 1,2,3,0,1,0,1,1,1,1
  126. 1260 '                     MONKEY TREE
  127. 1270  DATA 7,6,1.732051,1.8,2
  128. 1280  DATA 1,2,4,5,2,4,1,2,2,1,0,0
  129. 1290  DATA 3,1,1,4,2,2,1
  130. 1300 '----- END DATA ------------------
  131.